home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Dr. Windows 3
/
dr win3.zip
/
dr win3
/
WINFONTS
/
SYSFON10.ZIP
/
SYSFON.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-01-22
|
16KB
|
463 lines
PROGRAM SysFon;
{ Version 1.0, 01/22/93 - written by Peter Karrer, pkarrer@bernina.ethz.ch }
{$M 16384,16384}
{$R SYSFON.RES}
{$I-}
USES WObjects, WinTypes, WinProcs, Strings, Win31, CommDlg;
CONST
appName: PCHAR = 'SysFon';
fntHdSize = 126;
fonHdSize = 356;
TYPE
FontDirEntry =
RECORD
version: WORD;
size: LONGINT;
copyright: ARRAY[0..59] OF CHAR;
typ, point, vRes, hRes, asc, iLead, eLead: WORD;
ita, usc, strike: byte;
weight: WORD;
charset: BYTE;
w, h: WORD;
pitchAndFam: BYTE;
avgW, maxW: WORD;
fCh, lCh, dCh, bCh: BYTE;
widthBytes: WORD;
dev, face, rsvd: LONGINT;
END;
HdrBufR = RECORD
constantStuff: ARRAY[0..$DF] OF BYTE;
fntSize: WORD;
otherStuff: ARRAY[0..48] OF BYTE;
moduleDescriptionLen: BYTE;
moduleDescription: ARRAY[0..73] OF CHAR;
trailer: ARRAY[0..31] OF CHAR;
END;
TThisApp = OBJECT(TApplication)
PROCEDURE InitMainWindow; VIRTUAL;
END;
PFnWin = ^TFnWin;
TFnWin = OBJECT(TDlgWindow)
dc: HDC;
fnH: HFont;
cf: TChooseFont;
lf: TLogFont;
tm: TTextMetric;
fd: FontDirEntry;
ofn: TOpenFileName;
faceName, orgFaceName: ARRAY[0..lf_FaceSize-1] OF CHAR;
CONSTRUCTOR Init;
PROCEDURE SetupWindow; VIRTUAL;
FUNCTION GetClassName: PCHAR; VIRTUAL;
PROCEDURE GetWindowClass(VAR c: TWndClass); VIRTUAL;
PROCEDURE SelectFont(VAR msg: TMessage); VIRTUAL id_first + 101;
PROCEDURE SaveFont(VAR msg: TMessage); VIRTUAL id_first + 103;
PROCEDURE Help(VAR msg: TMessage); VIRTUAL id_first + 102;
PROCEDURE WMPaint(VAR msg: TMessage); VIRTUAL wm_first + wm_Paint;
PROCEDURE FillFontDir(wBytes: WORD);
PROCEDURE WMDestroy(VAR msg: TMessage); VIRTUAL wm_first + wm_Destroy;
END;
VAR
thisApp: TThisApp;
outF: FILE;
FUNCTION HelpDlgProc(win: HWnd; m, w: WORD; l: LONGINT): BOOL; EXPORT;
BEGIN
HelpDlgProc := FALSE;
IF m = wm_InitDialog THEN BEGIN
HelpDlgProc := TRUE;
END ELSE IF m = wm_Command THEN BEGIN
EndDialog(win, 0);
HelpDlgProc := TRUE;
END;
END;
PROCEDURE TFnWin.FillFontDir(wBytes: WORD);
{Fill FontDir structure with info from text metrics and computed FNT size}
BEGIN
WITH fd, tm DO BEGIN
version := 512;
face := wBytes * tmHeight + (tmLastChar - tmFirstChar) * 4 + fntHdSize;
size := face + STRLEN(faceName) + 1;
FillChar(copyright, SIZEOF(copyright), #0);
STRPCOPY(copyright, '(c) of orig. font "' + STRPAS(orgFaceName) + '" applies');
typ := 0;
point := (cf.iPointSize + 5) DIV 10;
vRes := tmDigitizedAspectY;
hRes := tmDigitizedAspectX;
asc := tmAscent;
iLead := tmInternalLeading;
eLead := tmExternalLeading;
ita := tmItalic;
usc := tmUnderlined;
strike := tmStruckOut;
weight := tmWeight;
charset := ANSI_Charset;
h := tmHeight;
pitchAndFam := tmPitchAndFamily AND NOT (TMPF_Vector OR TMPF_TrueType OR TMPF_Device);
IF (pitchAndFam AND TMPF_Fixed_Pitch) <> 0 THEN BEGIN {*not* fixed pitch}
w := 0;
END ELSE BEGIN
w := tmAveCharWidth;
END;
avgW := tmAveCharWidth;
maxW := tmMaxCharWidth;
fCh := tmFirstChar;
lCh := tmLastChar;
dCh := tmDefaultChar - tmFirstChar;
bCh := tmBreakChar - tmFirstChar;
widthBytes := wBytes;
dev := 0;
rsvd := 0;
END;
END;
CONSTRUCTOR TFnWin.Init;
BEGIN
TDlgWindow.Init(NIL, appName);
END;
FUNCTION TFnWin.GetClassName: PCHAR;
VAR
d: PCHAR;
BEGIN
GetClassName := appName;
END;
PROCEDURE TFnWin.GetWindowClass(VAR c: TWndClass);
BEGIN
TDlgWindow.GetWindowClass(c);
{c.hIcon := LoadIcon(hInstance, appName);}
{doesn't work with TDlgWindow!?, do it in SetupWindow }
END;
PROCEDURE TFnWin.SetupWindow;
BEGIN
TDlgWindow.SetupWindow;
SetClassWord(hWindow, GCW_HICON, LoadIcon(hInstance, appName));
GetObject(GetStockObject(System_Font), SIZEOF(TLogFont), @lf);
lf.lfFaceName[31] := #0; {safety}
fnH := CreateFontIndirect(lf);
END;
PROCEDURE TFnWin.WMPaint(VAR msg: TMessage);
VAR
ps: TPaintStruct;
b: HBrush;
pen: HPen;
r: TRect;
w, h, h1: INTEGER;
oldfnH: HFont;
BEGIN
{Paint simulated window title and menu bar}
BeginPaint(hWindow, ps);
GetClientRect(hWindow, r);
w := r.right - r.left - 11;
SetBkMode(ps.hDC, transparent);
oldfnH := SelectObject(ps.hDC, fnH);
GetTextMetrics(ps.hDC, tm);
h := GetSystemMetrics(sm_CYSize);
IF tm.tmHeight > h THEN BEGIN
h := tm.tmHeight - 1;
END;
h1 := GetSystemMetrics(sm_CYSize);
IF (tm.tmHeight + tm.tmExternalLeading) >= h1 THEN BEGIN
h1 := tm.tmHeight + tm.tmExternalLeading + 1;
END;
SetRect(r, 11, 11, w, 11 + h);
b := CreateSolidBrush(GetSysColor(color_ActiveCaption));
FillRect(ps.hDC, r, b);
DeleteObject(b);
pen := SelectObject(ps.hDC, CreatePen(ps_Solid, 1, GetSysColor(color_WindowFrame)));
MoveTo(ps.hDC, 10, 10);
LineTo(ps.hDC, w, 10);
LineTo(ps.hDC, w, 10 + h + 1);
LineTo(ps.hDC, 10, 10 + h + 1);
LineTo(ps.hDC, 10, 10);
MoveTo(ps.hDC, 10, 10 + h + 2);
LineTo(ps.hDC, 10, 10 + h + 2 + h1);
LineTo(ps.hDC, w, 10 + h + 2 + h1);
LineTo(ps.hDC, w, 10 + h + 1);
DeleteObject(SelectObject(ps.hDC, pen));
SetTextColor(ps.hDC, GetSysColor(color_CaptionText));
DrawText(ps.hDC, 'Sample Window Title', -1, r, dt_Center OR dt_VCenter OR dt_SingleLine);
SetRect(r, 11, 10 + h + 2, w, 10 + h + 2 + h1);
b := CreateSolidBrush(GetSysColor(color_Menu));
FillRect(ps.hDC, r, b);
DeleteObject(b);
r.bottom := r.bottom - 1;
SetTextColor(ps.hDC, GetSysColor(color_MenuText));
DrawText(ps.hDC, ' &Sample Menu Bar', -1, r, dt_VCenter OR dt_SingleLine);
SelectObject(ps.hDC, oldfnH);
EndPaint(hWindow, ps);
END;
PROCEDURE TFnWin.Help(VAR msg: TMessage);
VAR
inst: TFarProc;
BEGIN
inst := MakeProcInstance(@HelpDlgProc, hInstance);
DialogBox(hInstance, 'SYSFONH', hWindow, inst);
FreeProcInstance(inst);
END;
PROCEDURE TFnWin.SelectFont(VAR msg: TMessage);
VAR
oldFnH: HFont;
mDC: HDC;
BEGIN
FillChar(cf, SIZEOF(TChooseFont), #0);
WITH cf DO BEGIN
lStructSize := SIZEOF(TChooseFont);
hWndOwner := hWindow;
{nFontType := Screen_FontType;}
lpLogFont := @lF;
flags := CF_ScreenFonts OR CF_InitToLogFontStruct;
END;
{Standard ChooseFont dialog}
IF ChooseFont(cf) THEN BEGIN
{Create a memory device context}
dc := GetDC(hWindow);
mDC := CreateCompatibleDC(dc);
ReleaseDC(hWindow, dc);
{Create and select chosen font, get text metrics info}
DeleteObject(fnH);
fnH := CreateFontIndirect(lf);
lf.lfFaceName[31] := #0; {safety}
InvalidateRect(hWindow, NIL, TRUE);
oldFnH := SelectObject(mDC, fnH);
GetTextMetrics(mDC, tm);
IF lf.lfCharset <> ANSI_CharSet THEN BEGIN
MessageBeep(mb_IconExclamation);
MessageBox(0, 'Character set is not ANSI', lf.lfFaceName, mb_OK OR mb_IconExclamation);
END;
IF (tm.tmFirstChar > 32) OR (tm.tmLastChar < 255) THEN BEGIN
MessageBeep(mb_IconExclamation);
MessageBox(0, 'Font doesn''t contain all characters from 0x20 to 0xFF',
lf.lfFaceName, mb_OK OR mb_IconExclamation);
END;
{Cleanup}
SelectObject(mDC, oldFnH);
DeleteDC(mDC);
END;
END;
PROCEDURE TFnWin.SaveFont(VAR msg: TMessage);
VAR
wBytes: WORD;
oldFnH: HFont;
off, w, h, ix, ix1, ix2: WORD;
mDC, mDC1: HDC;
bmH, bmH1: HBitmap;
raster: ARRAY[0..511] OF BYTE;
st: ARRAY[0..1] OF